home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tm / tm-ew-d.el.z / tm-ew-d.el
Encoding:
Text File  |  1998-05-21  |  7.9 KB  |  266 lines
  1. ;;; tm-ew-d.el --- RFC 2047 based encoded-word decoder for GNU Emacs
  2.  
  3. ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
  4.  
  5. ;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
  6. ;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
  7. ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  8. ;; Created: 1995/10/03
  9. ;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'.
  10. ;;    Renamed: 1993/06/03 to tiny-mime.el.
  11. ;;    Renamed: 1995/10/03 from tiny-mime.el. (split off encoder)
  12. ;; Version: $Revision: 7.40 $
  13. ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
  14.  
  15. ;; This file is part of tm (Tools for MIME).
  16.  
  17. ;; This program is free software; you can redistribute it and/or
  18. ;; modify it under the terms of the GNU General Public License as
  19. ;; published by the Free Software Foundation; either version 2, or (at
  20. ;; your option) any later version.
  21.  
  22. ;; This program is distributed in the hope that it will be useful, but
  23. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  24. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  25. ;; General Public License for more details.
  26.  
  27. ;; You should have received a copy of the GNU General Public License
  28. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  29. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  30. ;; Boston, MA 02111-1307, USA.
  31.  
  32. ;;; Code:
  33.  
  34. (require 'emu)
  35. (require 'std11)
  36. (require 'mel)
  37. (require 'tm-def)
  38. (require 'tl-str)
  39.  
  40.  
  41. ;;; @ version
  42. ;;;
  43.  
  44. (defconst tm-ew-d/RCS-ID
  45.   "$Id: tm-ew-d.el,v 7.40 1997/03/06 17:53:51 morioka Exp $")
  46. (defconst mime/eword-decoder-version (get-version-string tm-ew-d/RCS-ID))
  47.  
  48.  
  49. ;;; @ MIME encoded-word definition
  50. ;;;
  51.  
  52. (defconst mime/encoded-text-regexp "[!->@-~]+")
  53. (defconst mime/encoded-word-regexp (concat (regexp-quote "=?")
  54.                        "\\("
  55.                        mime/charset-regexp
  56.                        "\\)"
  57.                        (regexp-quote "?")
  58.                        "\\(B\\|Q\\)"
  59.                        (regexp-quote "?")
  60.                        "\\("
  61.                        mime/encoded-text-regexp
  62.                        "\\)"
  63.                        (regexp-quote "?=")))
  64.  
  65.  
  66. ;;; @ for string
  67. ;;;
  68.  
  69. (defun mime-eword/decode-string (string &optional must-unfold)
  70.   "Decode MIME encoded-words in STRING.
  71.  
  72. STRING is unfolded before decoding.
  73.  
  74. If an encoded-word is broken or your emacs implementation can not
  75. decode the charset included in it, it is not decoded.
  76.  
  77. If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
  78. if there are in decoded encoded-words (generated by bad manner MUA
  79. such as a version of Net$cape). [tm-ew-d.el]"
  80.   (setq string (std11-unfold-string string))
  81.   (let ((dest "")(ew nil)
  82.     beg end)
  83.     (while (and (string-match mime/encoded-word-regexp string)
  84.         (setq beg (match-beginning 0)
  85.               end (match-end 0))
  86.         )
  87.       (if (> beg 0)
  88.       (if (not
  89.            (and (eq ew t)
  90.             (string-match "^[ \t]+$" (substring string 0 beg))
  91.             ))
  92.           (setq dest (concat dest (substring string 0 beg)))
  93.         )
  94.     )
  95.       (setq dest
  96.         (concat dest
  97.             (mime/decode-encoded-word
  98.              (substring string beg end) must-unfold)
  99.             ))
  100.       (setq string (substring string end))
  101.       (setq ew t)
  102.       )
  103.     (concat dest string)
  104.     ))
  105.  
  106.  
  107. ;;; @ for region
  108. ;;;
  109.  
  110. (defun mime-eword/decode-region (start end &optional unfolding must-unfold)
  111.   "Decode MIME encoded-words in region between START and END.
  112.  
  113. If UNFOLDING is not nil, it unfolds before decoding.
  114.  
  115. If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
  116. if there are in decoded encoded-words (generated by bad manner MUA
  117. such as a version of Net$cape). [tm-ew-d.el]"
  118.   (interactive "*r")
  119.   (save-excursion
  120.     (save-restriction
  121.       (narrow-to-region start end)
  122.       (if unfolding
  123.       (mime/unfolding)
  124.     )
  125.       (goto-char (point-min))
  126.       (while (re-search-forward (concat "\\(" mime/encoded-word-regexp "\\)"
  127.                                         "\\(\n?[ \t]\\)+"
  128.                                         "\\(" mime/encoded-word-regexp "\\)")
  129.                                 nil t)
  130.     (replace-match "\\1\\6")
  131.         (goto-char (point-min))
  132.     )
  133.       (let (charset encoding text)
  134.     (while (re-search-forward mime/encoded-word-regexp nil t)
  135.       (insert (mime/decode-encoded-word
  136.            (prog1
  137.                (buffer-substring (match-beginning 0) (match-end 0))
  138.              (delete-region (match-beginning 0) (match-end 0))
  139.              ) must-unfold))
  140.       ))
  141.       )))
  142.  
  143.  
  144. ;;; @ for message header
  145. ;;;
  146.  
  147. (defun mime/decode-message-header ()
  148.   "Decode MIME encoded-words in message header. [tm-ew-d.el]"
  149.   (interactive "*")
  150.   (save-excursion
  151.     (save-restriction
  152.       (narrow-to-region (goto-char (point-min))
  153.             (progn (re-search-forward "^$" nil t) (point)))
  154.       (mime-eword/decode-region (point-min) (point-max) t)
  155.       )))
  156.  
  157. (defun mime/unfolding ()
  158.   (goto-char (point-min))
  159.   (let (field beg end)
  160.     (while (re-search-forward std11-field-head-regexp nil t)
  161.       (setq beg (match-beginning 0)
  162.             end (std11-field-end))
  163.       (setq field (buffer-substring beg end))
  164.       (if (string-match mime/encoded-word-regexp field)
  165.           (save-restriction
  166.             (narrow-to-region (goto-char beg) end)
  167.             (while (re-search-forward "\n\\([ \t]\\)" nil t)
  168.               (replace-match
  169.                (match-string 1))
  170.               )
  171.         (goto-char (point-max))
  172.         ))
  173.       )))
  174.  
  175.  
  176. ;;; @ encoded-word decoder
  177. ;;;
  178.  
  179. (defun mime/decode-encoded-word (word &optional must-unfold)
  180.   "Decode WORD if it is an encoded-word.
  181.  
  182. If your emacs implementation can not decode the charset of WORD, it
  183. returns WORD.  Similarly the encoded-word is broken, it returns WORD.
  184.  
  185. If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
  186. if there are in decoded encoded-word (generated by bad manner MUA such
  187. as a version of Net$cape). [tm-ew-d.el]"
  188.   (or (if (string-match mime/encoded-word-regexp word)
  189.       (let ((charset
  190.          (substring word (match-beginning 1) (match-end 1))
  191.          )
  192.         (encoding
  193.          (upcase
  194.           (substring word (match-beginning 2) (match-end 2))
  195.           ))
  196.         (text
  197.          (substring word (match-beginning 3) (match-end 3))
  198.          ))
  199.             (condition-case err
  200.                 (mime/decode-encoded-text charset encoding text must-unfold)
  201.               (error
  202.                (and (add-text-properties 0 (length word)
  203.                      (and tm:warning-face
  204.                           (list 'face tm:warning-face))
  205.                      word)
  206.                     word)))
  207.             ))
  208.       word))
  209.  
  210.  
  211. ;;; @ encoded-text decoder
  212. ;;;
  213.  
  214. (defun mime/decode-encoded-text (charset encoding string &optional must-unfold)
  215.   "Decode STRING as an encoded-text.
  216.  
  217. If your emacs implementation can not decode CHARSET, it returns nil.
  218.  
  219. If ENCODING is not \"B\" or \"Q\", it occurs error.
  220. So you should write error-handling code if you don't want break by errors.
  221.  
  222. If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
  223. if there are in decoded encoded-text (generated by bad manner MUA such
  224. as a version of Net$cape). [tm-ew-d.el]"
  225.   (let ((cs (mime-charset-to-coding-system charset)))
  226.     (if cs
  227.     (let ((dest
  228.                (cond
  229.                 ((string-equal "B" encoding)
  230.                  (if (and (string-match mime/B-encoded-text-regexp string)
  231.                           (string-equal string (match-string 0 string)))
  232.                      (base64-decode-string string)
  233.                    (error "Invalid encoded-text %s" string)))
  234.                 ((string-equal "Q" encoding)
  235.                  (if (and (string-match mime/Q-encoded-text-regexp string)
  236.                           (string-equal string (match-string 0 string)))
  237.                      (q-encoding-decode-string string)
  238.                    (error "Invalid encoded-text %s" string)))
  239.                 (t
  240.                  (error "Invalid encoding %s" encoding)
  241.                  )))
  242.               )
  243.       (if dest
  244.           (progn
  245.         (setq dest (decode-coding-string dest cs))
  246.         (if must-unfold
  247.             (mapconcat (function
  248.                 (lambda (chr)
  249.                   (cond
  250.                                    ((eq chr ?\n) "")
  251.                                    ((eq chr ?\t) " ")
  252.                                    (t (char-to-string chr)))
  253.                   ))
  254.                    (std11-unfold-string dest)
  255.                    "")
  256.           dest)
  257.         ))))))
  258.  
  259.  
  260. ;;; @ end
  261. ;;;
  262.  
  263. (provide 'tm-ew-d)
  264.  
  265. ;;; tm-ew-d.el ends here
  266.